{$s-,g+,i-}
{**********************************************************}
{       DPMI-Unit pro Turbo Pascal pro Windows             }
{       DPMI-funkce jsou pod systemem Windows k dispozici  }
{       jenom ve standardnim a rozsirenem modu.            }
{       Copyright (c) 1991 by FE                           }
{**********************************************************}

unit DPMI;
interface
type Registers386=record
     case byte of 1:(EDI,ESI,EBP,reserved,EBX,EDX,ECX,EAX:Longint;
		    Flags,ES,DS,FS,GS,IP,CS,SP,SS:Word;);
		  2:(DI,DIh,SI,SIh,BP,BPh:Word;reserved2:Longint;
		    BX,BXh,DX,DXh,CX,CXh,AX,AXh:Word;);
		  3:(reserved3:array[0..15]of byte;
		    BL,BH,BLh,BHh,DL,DH,DLh,DHh,CL,CH,CLh,CHh,AL,AH,ALh,AHh:Byte;);
	end;

     PDescriptor = ^TDescriptor;
     TDescriptor = record
	LimitLo: Word;
	BaseLo: Word;
	BaseHi1: Byte;
	Flags: Byte;
	LimitAndFlags: Byte;
	BaseHi2: Byte;
     end;

     PHSRecord = ^THSRecord;
     THSRecord = record
	SelectorFromLDT: Word;
	HandleFromAlloc: LongInt;
     end;



Function Create16BitAlias(S32: Word; Offset: LongInt): Word;
Function Global32BitAlloc(VAR Selector: Word; Size: LongInt): Boolean;
Function Global32BitFree(Selector: Word): Boolean;
Function CreateMapSelector(P: Pointer; Size: LongInt): Word;


Function FreeLdtDescriptor(Selector: Word): Boolean;
Function CreateDsAliasCs(CodePtr:pointer):pointer;
Function DOS_GetMem(size:Word;var RealSegment:Word):Pointer;
Function DOS_FreeMem(p:Pointer):Boolean;
Function MapRealModeSegment(segment:Word):Word;
Procedure GetRMIntVec(IntNo: Byte; var Vector: Pointer);
Procedure SetRMIntVec(IntNo: Byte;Vector: Pointer);
Function DPMI_Intr(IntNo:Byte;var r:Registers386):Boolean;
Function DPMI_CallRealProc(RealProc:Pointer;var r:Registers386):Boolean;

Procedure SetIntVec_CB(IntNo: Byte;Vector: Pointer);

Const	_DPMI=$31;

	LDTAllocDescriptor   = $000;	{ Deskriptor-Management }
        LDTFreeDescriptor    = $001;
        LDTSeg2Descriptor    = $002;
	LDTGetNextSelINCVal  = $003;
        LDTGetSegBazeAddr    = $006;
	LDTSetDescriptorBase = $007;
	LDTSetSegSize	     = $008;
	LDTSetDescriptorAR   = $009;
	CreatDsAliasCs	     = $00A;
        LDTGetDescriptor     = $00B;
	LDTSetDescriptor     = $00C;
        LDTAlocSpecDescriptor= $00C;

	AlocDosMemBlk	     = $100;	{ DOS-zprava pameti }
	FreeDosMemBlk	     = $101;

	GetRealMIntVec       = $200;	{ Interrupt-funkce }
	SetRealMIntVec       = $201;
	SimulateRMint        = $300;
	SimulateRMproc       = $301;
	dpmiGetRMCB          = $303;

	GetDPMIVersion       = $400;	{ Informacni funkce }

	GetFreeMemInfo       = $500;	{ Simulacni funkce }
	AllocMemBlock        = $501;
	FreeMemBlock         = $502;
	ResizeMemBlock       = $503;
	LockLinearRegion     = $600;
	UnlockLinearRegion   = $601;
	GetPageSize          = $604;

	MapPhysicalAddress   = $800;	{ Mapovaci funkce }



{$ifdef windows}
var	RealModeRegs:Registers386;
{$endif}
implementation

Function FreeLdtDescriptor(Selector: Word): Boolean; assembler;
asm
	MOV	BX, Selector
	MOV	AX, LDTFreeDescriptor
	INT	DPMI

        MOV	AX,False
	JC	@@1
	INC	AX
@@1:
end;

Function CreateDsAliasCs(CodePtr:pointer):pointer; assembler;
asm
	mov	ax,CreatDsAliasCs
	mov	bx,word ptr CodePtr+2
	int	_DPMI			{v AX vraci hodnotu}
        mov	dx,0	{nemeni CY}
        mov	cx,0
        jc	@ErrVen
        mov	dx,ax
        mov	ax,word ptr CodePtr
@ErrVen:
end;

Procedure GetDescriptor(VAR D: TDescriptor; Selector: Word);
begin
	asm
	MOV   BX, Selector
	LES   DI, D
	MOV   AX, LDTGetDescriptor
	INT   _DPMI
	end;
end;

Procedure SetDescriptor(D: TDescriptor; Selector: Word);
begin
	asm
	MOV	BX, Selector
	mov	ax,ds
	mov	es,ax
	LEA	DI, [BP+OFFSET D]
	MOV	AX, LDTSetDescriptor
	INT	_DPMI
	end;
end;



Function DPMI_Intr(IntNo:Byte;var r:Registers386):Boolean;
var result:Boolean;
begin
DPMI_Intr:=False;
with r do
  begin
  IP:=0; {jsou ignorovany}
  CS:=0;

  SP:=0; {uzivatelsky zasobnik}
  SS:=0;
  end;

	asm
	mov	AX,SimulateRMInt
	mov	BL,IntNo
	mov	BH,0
	mov	CX,0
	push	SS
	pop	ES
	les	DI,[r]
	int	_DPMI
	mov	result,0
	jc	@@1
	mov	result,1
@@1:  end;
DPMI_Intr:=Result;
end;

Function DPMI_CallRealProc(RealProc:Pointer;var r:Registers386):Boolean;
var result:Boolean;
begin
DPMI_CallRealProc:=False;
with r do
  begin
  IP:=ofs(RealProc); {adresa procedury}
  CS:=seg(RealProc);

  SP:=0; {uzivatelsky zasobnik}
  SS:=0;
  end;

	asm
	mov	AX,SimulateRMProc
	mov	BX,0
	mov	CX,0
	push	SS
	pop	ES
	les	DI,[r]
	int	_DPMI
	mov	result,0
	jc	@@1
	mov	result,1
@@1:  end;
DPMI_CallRealProc:=Result;
end;


Function MapRealModeSegment(segment:Word):Word; assembler;
asm
	mov	ax,2
	mov	bx,Segment
	int	_DPMI			{v AX vraci hodnotu}
end;

Function DOS_GetMem(size:Word;var RealSegment:Word):Pointer; assembler;
asm
	mov	ax,AlocDosMemBlk
	mov	bx,size
        add	bx,15
        shr	bx,4
        int	_DPMI
        jnc	@AlocOk
        xor	ax,ax
        xor	dx,dx
@AlocOk:push	es
	les	si,RealSegment
        mov	word ptr Es:Si,ax
        xor	ax,ax		{DX:AX obsahuje adresu v DOS pameti}
	pop	es
end;

Function DOS_FreeMem(p:Pointer):Boolean; assembler;
asm
	mov	ax,FreeDosMemBlk
	mov	dx,word ptr p+2
	int	_DPMI
	jnc	@FreeOk
	xor	ax,ax
@FreeOk:
end;

Procedure GetRMIntVec(IntNo: Byte; var Vector: Pointer); assembler;
asm
	mov	ax,GetRealMIntVec
	mov	bl,IntNo
	int	_DPMI
	push	es
	les	si,Vector
	mov	word ptr ES:SI,DX
	mov	word ptr ES:[SI+2],CX
	pop	es
end;

Procedure SetRMIntVec(IntNo: Byte;Vector: Pointer); assembler;
asm
	mov	CX,word ptr Vector+2
	mov	DX,word ptr Vector
	mov	ax,SetRealMIntVec
	mov	bl,IntNo
	int	_DPMI
end;


Procedure SetIntVec_CB(IntNo: Byte;Vector: Pointer); assembler;
asm
	push	es
	push	ds
	MOV	DI,OFFSET RealModeRegs
	MOV	ax,SEG RealModeRegs
	mov	es,ax
	lds	SI,Vector
	MOV	AX,dpmiGetRMCB
	INT	_DPMI
	MOV	AX,SetRealMIntVec
	MOV	BL,IntNo
	INT	_DPMI
	pop	ds
	pop	es
end;

{---------------slozene funkce----------------}
Function Create16BitAlias(S32: Word; Offset: LongInt): Word;
LABEL _Exit;
VAR
  LinearAddr: LongInt;
  ASelector: Word;
  D: TDescriptor;
begin
  Create16BitAlias := 0;
  ASelector := 0;
  asm
	MOV   AX, DS
	MOV   ES, AX
	LEA   DI, [BP+OFFSET D]
	MOV   BX, S32
	MOV   AX, LDTGetDescriptor       { cisty 32-Bit-Deskriptor }
	INT   _DPMI
	JC    _Exit
	MOV   AX, D.TDescriptor.BaseLo
	MOV   WORD PTR LinearAddr, AX
	MOV   AL, D.TDescriptor.BaseHi1
	MOV   BYTE PTR LinearAddr.2, AL
	MOV   AL, D.TDescriptor.BaseHi2
	MOV   BYTE PTR LinearAddr.3, AL
	end;
  LinearAddr := LinearAddr + Offset;
	asm
	MOV   CX, 1
	MOV   AX, LDTAllocDescriptor
	INT   _DPMI
	JC    @@2
	MOV   ASelector, AX
	MOV   BX, AX
	MOV   CX, Word Ptr LinearAddr.2
	MOV   DX, Word Ptr LinearAddr.0
	MOV   AX, LDTSetDescriptorBase
	INT   _DPMI
	JC    @@3

	XOR   CX, CX
	MOV   DX, $FFFF   { hranica segmentu je 64K }
	MOV   BX, ASelector
	MOV   AX, LDTSetSegSize
	INT   _DPMI
	JC    @@4


	MOV   AX, ASelector
	MOV   Word Ptr @Result, AX
	JMP   @@1
_Exit:
@@4:
@@3:
@@2:
@@1:
	end;
end;


Function Global32BitAlloc(VAR Selector: Word; Size: LongInt): Boolean;
VAR
  LinearAddr: LongInt;
  ASelector: Word;
  Handle: LongInt;
  P: PHSRecord;
  Limit: LongInt;
begin
  Global32BitAlloc := False;
   IF Size >= $100000 THEN
    IF Size MOD 4096 <> 0 THEN
      Size := Size OR $FFF + 1;
      { Alokace nad 1 MByte museji mit stranovu granulaci (4KB) }
  ASelector := 0;
  Limit := Size-1;
	asm
	MOV   CX, Word Ptr Size.0
	MOV   BX, Word Ptr Size.2
	MOV   AX, AllocMemBlock
	INT   _DPMI
	JC    @@1
	MOV   Word Ptr Handle.0, DI
	MOV   Word Ptr Handle.2, SI
	MOV   Word Ptr LinearAddr.0, CX
	MOV   Word Ptr LinearAddr.2, BX

	MOV   CX, 1
	MOV   AX, LDTAllocDescriptor
	INT   _DPMI
	JC    @@2
	MOV   ASelector, AX
	MOV   BX, AX
	MOV   CX, Word Ptr LinearAddr.2
	MOV   DX, Word Ptr LinearAddr.0
	MOV   AX, LDTSetDescriptorBase
	INT   _DPMI
	JC    @@3

	MOV   CX, Word Ptr Limit.2
	MOV   DX, Word Ptr Limit.0
	MOV   BX, ASelector
	MOV   AX, LDTSetSegSize
	INT   _DPMI
	JC    @@4

	INC   Word Ptr @Result
	MOV   AX, ASelector
	LES   DI, Selector
	STOSW
	JMP   @@1
@@4:
@@3:
@@2:
	MOV   SI, Word Ptr Handle.2
	MOV   DI, Word Ptr Handle.0
	MOV   AX, FreeMemBlock
	INT   _DPMI
@@1:
  end;
  IF ASelector = 0 THEN
    Exit;
  New(P);
  P^.HandleFromAlloc := Handle;
  P^.SelectorFromLDT := ASelector;
end;


Function Global32BitFree(Selector: Word): Boolean;
VAR
  Handle: LongInt;
  I: Integer;
begin
  Global32BitFree := False;
	asm
	MOV   BX, Selector
	MOV   AX, LDTFreeDescriptor
	INT   _DPMI
	JC    @@1
	MOV   SI, Word Ptr Handle.2
	MOV   DI, Word Ptr Handle.0
	MOV   AX, FreeMemBlock
	INT   _DPMI
	JC    @@2
	INC   Word Ptr @Result
@@2:
@@1:
  	end;
end;


Function CreateMapSelector(P: Pointer; Size: LongInt): Word;
VAR
  LinearAddr: LongInt;
  ASelector: Word;
begin
  CreateMapSelector := 0;
	asm
	MOV   BX, Word Ptr P.2
	MOV   CX, Word Ptr P.0
	MOV   SI, Word Ptr Size.2
	MOV   DI, Word Ptr Size.0
	MOV   AX, MapPhysicalAddress
	INT   _DPMI
	JC    @@1
	MOV   Word Ptr LinearAddr.0, CX
	MOV   Word Ptr LinearAddr.2, BX
	MOV   CX, 1
	MOV   AX, LDTAllocDescriptor
	INT   _DPMI
	JC    @@2

	MOV   ASelector, AX
	MOV   BX, AX
	MOV   CX, Word Ptr LinearAddr.2
	MOV   DX, Word Ptr LinearAddr.0
	MOV   AX, LDTSetDescriptorBase
	INT   _DPMI
	JC    @@3

	MOV   CX, Word Ptr Size.2
	MOV   DX, Word Ptr Size.0
	MOV   BX, ASelector
	MOV   AX, LDTSetSegSize
	INT   _DPMI
	JC    @@4
	MOV   AX, ASelector
	MOV   Word Ptr @Result, AX
@@4:
@@3:
@@2:
@@1:
	end;
end;


Function ValidSelector(S: Word): Boolean;	assembler;
asm
	MOV	AX, WORD PTR S
	LSL	BX,AX
        mov	AX,False
	JNZ	@@1
        mov	AX,True
@@1:
end;


end.

